home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / libguile / unif.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-08-16  |  49.9 KB  |  2,258 lines
  1. /*    Copyright (C) 1995 Free Software Foundation, Inc.
  2.  * 
  3.  * This program is free software; you can redistribute it and/or modify
  4.  * it under the terms of the GNU General Public License as published by
  5.  * the Free Software Foundation; either version 2, or (at your option)
  6.  * any later version.
  7.  * 
  8.  * This program is distributed in the hope that it will be useful,
  9.  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10.  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11.  * GNU General Public License for more details.
  12.  * 
  13.  * You should have received a copy of the GNU General Public License
  14.  * along with this software; see the file COPYING.  If not, write to
  15.  * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  16.  *
  17.  * As a special exception, the Free Software Foundation gives permission
  18.  * for additional uses of the text contained in its release of GUILE.
  19.  *
  20.  * The exception is that, if you link the GUILE library with other files
  21.  * to produce an executable, this does not by itself cause the
  22.  * resulting executable to be covered by the GNU General Public License.
  23.  * Your use of that executable is in no way restricted on account of
  24.  * linking the GUILE library code into it.
  25.  *
  26.  * This exception does not however invalidate any other reasons why
  27.  * the executable file might be covered by the GNU General Public License.
  28.  *
  29.  * This exception applies only to the code released by the
  30.  * Free Software Foundation under the name GUILE.  If you copy
  31.  * code from other Free Software Foundation releases into a copy of
  32.  * GUILE, as the General Public License permits, the exception does
  33.  * not apply to the code that you add in this way.  To avoid misleading
  34.  * anyone as to the status of such modified files, you must delete
  35.  * this exception notice from them.
  36.  *
  37.  * If you write modifications of your own for GUILE, it is your choice
  38.  * whether to permit this exception to apply to your modifications.
  39.  * If you do not wish that, delete this exception notice.  
  40.  */
  41.  
  42.  
  43. #include <stdio.h>
  44. #include "_scm.h"
  45. static char s_vector[] = "vector";
  46. static char s_array[] = "array";
  47.  
  48.  
  49.  
  50.  
  51. /* The set of uniform scm_vector types is:
  52.  *  Vector of:         Called:
  53.  * char            string
  54.  * boolean        bvect
  55.  * signed int        ivect
  56.  * unsigned int        uvect
  57.  * float        fvect
  58.  * double        dvect
  59.  * complex double    cvect
  60.  */
  61.  
  62. #ifndef STDC_HEADERS
  63. int ungetc P ((int c, FILE * stream));
  64. sizet fwrite ();
  65. #endif
  66.  
  67. long scm_tc16_array;
  68.  
  69. char scm_s_resizuve[] = "vector-set-length!";
  70. SCM 
  71. scm_resizuve (vect, len)
  72.      SCM vect, len;
  73. {
  74.   long l = INUM (len);
  75.   sizet siz, sz;
  76.   ASRTGO (NIMP (vect), badarg1);
  77.   switch TYP7
  78.     (vect)
  79.     {
  80.     default:
  81.     badarg1:scm_wta (vect, (char *) ARG1, scm_s_resizuve);
  82.     case tc7_string:
  83.       ASRTGO (vect != nullstr, badarg1);
  84.       sz = sizeof (char);
  85.       l++;
  86.       break;
  87.     case tc7_vector:
  88.       ASRTGO (vect != nullvect, badarg1);
  89.       sz = sizeof (SCM);
  90.       break;
  91. #ifdef ARRAYS
  92.     case tc7_bvect:
  93.       l = (l + LONG_BIT - 1) / LONG_BIT;
  94.     case tc7_uvect:
  95.     case tc7_ivect:
  96.       sz = sizeof (long);
  97.       break;
  98. #ifdef FLOATS
  99. #ifdef SINGLES
  100.     case tc7_fvect:
  101.       sz = sizeof (float);
  102.       break;
  103. #endif
  104.     case tc7_dvect:
  105.       sz = sizeof (double);
  106.       break;
  107.     case tc7_cvect:
  108.       sz = 2 * sizeof (double);
  109.       break;
  110. #endif
  111. #endif
  112.     }
  113.   ASSERT (INUMP (len), len, ARG2, scm_s_resizuve);
  114.   if (!l)
  115.     l = 1L;
  116.   siz = l * sz;
  117.   if (siz != l * sz)
  118.     scm_wta (MAKINUM (l * sz), (char *) NALLOC, scm_s_resizuve);
  119.   DEFER_INTS;
  120.   SETCHARS (vect,
  121.         ((char *)
  122.          scm_must_realloc (CHARS (vect),
  123.                    (long) LENGTH (vect) * sz,
  124.                    (long) siz,
  125.                    scm_s_resizuve)));
  126.   if (VECTORP (vect))
  127.  
  128.     {
  129.       sz = LENGTH (vect);
  130.       while (l > sz)
  131.     VELTS (vect)[--l] = UNSPECIFIED;
  132.     }
  133.   else if (STRINGP (vect))
  134.     CHARS (vect)[l - 1] = 0;
  135.   SETLENGTH (vect, INUM (len), TYP7 (vect));
  136.   ALLOW_INTS;
  137.   return vect;
  138. }
  139.  
  140. #ifdef ARRAYS
  141.  
  142. #ifdef FLOATS
  143. #ifdef SINGLES
  144. SCM 
  145. makflo (x)
  146.      float x;
  147. {
  148.   SCM z;
  149.   if (x == 0.0)
  150.     return flo0;
  151.   NEWCELL (z);
  152.   DEFER_INTS;
  153.   CAR (z) = tc_flo;
  154.   FLO (z) = x;
  155.   ALLOW_INTS;
  156.   return z;
  157. }
  158. #endif
  159. #endif
  160.  
  161. SCM 
  162. scm_make_uve (k, prot)
  163.      long k;
  164.      SCM prot;
  165. {
  166.   SCM v;
  167.   long i, type;
  168.   if (BOOL_T == prot)
  169.     {
  170.       i = sizeof (long) * ((k + LONG_BIT - 1) / LONG_BIT);
  171.       type = tc7_bvect;
  172.     }
  173.   else if (ICHRP (prot))
  174.  
  175.     {
  176.       i = sizeof (char) * k;
  177.       type = tc7_string;
  178.     }
  179.   else if (INUMP (prot))
  180.  
  181.     {
  182.       i = sizeof (long) * k;
  183.       if (INUM (prot) > 0)
  184.     type = tc7_uvect;
  185.       else
  186.     type = tc7_ivect;
  187.     }
  188.   else
  189. #ifdef FLOATS
  190.   if (IMP (prot) || !INEXP (prot))
  191. #endif
  192.     /* Huge non-unif vectors are NOT supported. */
  193.     return scm_make_vector (MAKINUM (k), SCM_UNDEFINED);    /* no special scm_vector */
  194. #ifdef FLOATS
  195. #ifdef SINGLES
  196.   else if (SINGP (prot))
  197.  
  198.     {
  199.       i = sizeof (float) * k;
  200.       type = tc7_fvect;
  201.     }
  202. #endif
  203.   else if (CPLXP (prot))
  204.     {
  205.       i = 2 * sizeof (double) * k;
  206.       type = tc7_cvect;
  207.     }
  208.   else
  209.     {
  210.       i = sizeof (double) * k;
  211.       type = tc7_dvect;
  212.     }
  213. #endif
  214.  
  215.   NEWCELL (v);
  216.   DEFER_INTS;
  217.   {
  218.     char *m;
  219.     m = scm_must_malloc ((i ? i : 1L), s_vector);
  220.     SETCHARS (v, (char *) m);
  221.   }
  222.   SETLENGTH (v, (k < LENGTH_MAX ? k : LENGTH_MAX), type);
  223.   ALLOW_INTS;
  224.   return v;
  225. }
  226.  
  227. static char s_uve_len[] = "uniform-vector-length";
  228. SCM 
  229. scm_uve_len (v)
  230.      SCM v;
  231. {
  232.   ASRTGO (NIMP (v), badarg1);
  233.   switch TYP7
  234.     (v)
  235.     {
  236.     default:
  237.     badarg1:scm_wta (v, (char *) ARG1, s_uve_len);
  238.     case tc7_bvect:
  239.     case tc7_string:
  240.     case tc7_uvect:
  241.     case tc7_ivect:
  242.     case tc7_fvect:
  243.     case tc7_dvect:
  244.     case tc7_cvect:
  245.     case tc7_vector:
  246.       return MAKINUM (LENGTH (v));
  247.     }
  248. }
  249.  
  250. SCM 
  251. scm_arrayp (v, prot)
  252.      SCM v, prot;
  253. {
  254.   int nprot = UNBNDP (prot), enclosed = 0;
  255.   if (IMP (v))
  256.  return BOOL_F;
  257. loop:
  258.   switch (TYP7 (v))
  259.     {
  260.     case tc7_smob:
  261.       if (!ARRAYP (v))
  262.     return BOOL_F;
  263.       if (nprot)
  264.     return BOOL_T;
  265.       if (enclosed++)
  266.     return BOOL_F;
  267.       v = ARRAY_V (v);
  268.       goto loop;
  269.     case tc7_bvect:
  270.       return nprot || BOOL_T==prot ? BOOL_T : BOOL_F;
  271.     case tc7_string:
  272.       return nprot || ICHRP(prot) ? BOOL_T : BOOL_F;
  273.     case tc7_uvect:
  274.       return nprot || (INUMP(prot) && INUM(prot)>0) ? BOOL_T : BOOL_F;
  275.     case tc7_ivect:
  276.       return nprot || (INUMP(prot) && INUM(prot)<=0) ? BOOL_T : BOOL_F;
  277. # ifdef FLOATS
  278. #  ifdef SINGLES
  279.     case tc7_fvect:
  280.       return nprot || (NIMP(prot) && SINGP(prot)) ? BOOL_T : BOOL_F;
  281. #  endif
  282.     case tc7_dvect:
  283.       return nprot || (NIMP(prot) && REALP(prot)) ? BOOL_T : BOOL_F;
  284.     case tc7_cvect:
  285.       return nprot || (NIMP(prot) && CPLXP(prot)) ? BOOL_T : BOOL_F;
  286. # endif
  287.     case tc7_vector:
  288.       return nprot || NULLP(prot) ? BOOL_T : BOOL_F;
  289.     default:;
  290.     }
  291.   return BOOL_F;
  292. }
  293. SCM 
  294. scm_array_rank (ra)
  295.      SCM ra;
  296. {
  297.   if (IMP (ra))
  298.  return INUM0;
  299.   switch (TYP7 (ra))
  300.     {
  301.     default:
  302.       return INUM0;
  303.     case tc7_string:
  304.     case tc7_vector:
  305.     case tc7_uvect:
  306.     case tc7_ivect:
  307.     case tc7_fvect:
  308.     case tc7_cvect:
  309.     case tc7_dvect:
  310.       return MAKINUM (1L);
  311.     case tc7_smob:
  312.       if (ARRAYP (ra))
  313.     return MAKINUM (ARRAY_NDIM (ra));
  314.       return INUM0;
  315.     }
  316. }
  317. static char s_array_dims[] = "array-dimensions";
  318. SCM 
  319. scm_array_dims (ra)
  320.      SCM ra;
  321. {
  322.   SCM res = EOL;
  323.   sizet k;
  324.   scm_array_dim *s;
  325.   if (IMP (ra))
  326.  return BOOL_F;
  327.   switch (TYP7 (ra))
  328.     {
  329.     default:
  330.       return BOOL_F;
  331.     case tc7_string:
  332.     case tc7_vector:
  333.     case tc7_bvect:
  334.     case tc7_uvect:
  335.     case tc7_ivect:
  336.     case tc7_fvect:
  337.     case tc7_cvect:
  338.     case tc7_dvect:
  339.       return scm_cons (MAKINUM (LENGTH (ra)), EOL);
  340.     case tc7_smob:
  341.       if (!ARRAYP (ra))
  342.     return BOOL_F;
  343.       k = ARRAY_NDIM (ra);
  344.       s = ARRAY_DIMS (ra);
  345.       while (k--)
  346.     res = scm_cons (s[k].lbnd ? scm_cons2 (MAKINUM (s[k].lbnd), MAKINUM (s[k].ubnd), EOL) :
  347.             MAKINUM (1 + (s[k].ubnd))
  348.             , res);
  349.       return res;
  350.     }
  351. }
  352. static char s_bad_ind[] = "Bad scm_array index";
  353. long 
  354. scm_aind (ra, args, what)
  355.      SCM ra, args;
  356.      char *what;
  357. {
  358.   SCM ind;
  359.   register long j;
  360.   register sizet pos = ARRAY_BASE (ra);
  361.   register sizet k = ARRAY_NDIM (ra);
  362.   scm_array_dim *s = ARRAY_DIMS (ra);
  363.   if (INUMP (args))
  364.  
  365.     {
  366.       ASSERT (1 == k, SCM_UNDEFINED, WNA, what);
  367.       return pos + (INUM (args) - s->lbnd) * (s->inc);
  368.     }
  369.   while (k && NIMP (args))
  370.     {
  371.       ind = CAR (args);
  372.       args = CDR (args);
  373.       ASSERT (INUMP (ind), ind, s_bad_ind, what);
  374.       j = INUM (ind);
  375.       ASSERT (j >= (s->lbnd) && j <= (s->ubnd), ind, OUTOFRANGE, what);
  376.       pos += (j - s->lbnd) * (s->inc);
  377.       k--;
  378.       s++;
  379.     }
  380.   ASSERT (0 == k && NULLP (args), SCM_UNDEFINED, WNA, what);
  381.   return pos;
  382. }
  383.  
  384. SCM 
  385. scm_make_ra (ndim)
  386.      int ndim;
  387. {
  388.   SCM ra;
  389.   NEWCELL (ra);
  390.   DEFER_INTS;
  391.   SETCDR (ra, scm_must_malloc ((long) (sizeof (scm_array) + ndim * sizeof (scm_array_dim)),
  392.                    "array"));
  393.   CAR (ra) = ((long) ndim << 17) + scm_tc16_array;
  394.   ARRAY_V (ra) = nullvect;
  395.   ALLOW_INTS;
  396.   return ra;
  397. }
  398.  
  399. static char s_bad_spec[] = "Bad scm_array dimension";
  400. /* Increments will still need to be set. */
  401. SCM 
  402. scm_shap2ra (args, what)
  403.      SCM args;
  404.      char *what;
  405. {
  406.   scm_array_dim *s;
  407.   SCM ra, spec, sp;
  408.   int ndim = scm_ilength (args);
  409.   ASSERT (0 <= ndim, args, s_bad_spec, what);
  410.   ra = scm_make_ra (ndim);
  411.   ARRAY_BASE (ra) = 0;
  412.   s = ARRAY_DIMS (ra);
  413.   for (; NIMP (args); s++, args = CDR (args))
  414.     {
  415.       spec = CAR (args);
  416.       if (IMP (spec))
  417.  
  418.     {
  419.       ASSERT (INUMP (spec) && INUM (spec) >= 0, spec, s_bad_spec, what);
  420.       s->lbnd = 0;
  421.       s->ubnd = INUM (spec) - 1;
  422.       s->inc = 1;
  423.     }
  424.       else
  425.     {
  426.       ASSERT (CONSP (spec) && INUMP (CAR (spec)), spec, s_bad_spec, what);
  427.       s->lbnd = INUM (CAR (spec));
  428.       sp = CDR (spec);
  429.       ASSERT (INUMP (CAR (sp)) && NULLP (CDR (sp)),
  430.           spec, s_bad_spec, what);
  431.       s->ubnd = INUM (CAR (sp));
  432.       s->inc = 1;
  433.     }
  434.     }
  435.   return ra;
  436. }
  437.  
  438. static char s_dims2ura[] = "dimensions->uniform-array";
  439. SCM 
  440. scm_dims2ura (dims, prot, fill)
  441.      SCM dims, prot, fill;
  442. {
  443.   sizet k, vlen = 1;
  444.   long rlen = 1;
  445.   scm_array_dim *s;
  446.   SCM ra;
  447.   if (INUMP (dims))
  448.       if (INUM (dims) < LENGTH_MAX)
  449.     {
  450.       SCM answer;
  451.       answer = scm_make_uve (INUM (dims), prot);
  452.       if (NNULLP (fill))
  453.         {
  454.           ASSERT (1 == scm_ilength (fill), fill, WNA, s_dims2ura);
  455.           scm_array_fill (answer, CAR (fill));
  456.         }
  457.       else
  458.         scm_array_fill (answer, prot);
  459.       return answer;
  460.     }
  461.     else
  462.       dims = scm_cons (dims, EOL);
  463.   ASSERT (NULLP (dims) || (NIMP (dims) && CONSP (dims)),
  464.       dims, ARG1, s_dims2ura);
  465.   ra = scm_shap2ra (dims, s_dims2ura);
  466.   CAR (ra) |= ARRAY_CONTIGUOUS;
  467.   s = ARRAY_DIMS (ra);
  468.   k = ARRAY_NDIM (ra);
  469.   while (k--)
  470.     {
  471.       s[k].inc = (rlen > 0 ? rlen : 0);
  472.       rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
  473.       vlen *= (s[k].ubnd - s[k].lbnd + 1);
  474.     }
  475.   if (rlen < LENGTH_MAX)
  476.     ARRAY_V (ra) = scm_make_uve ((rlen > 0 ? rlen : 0L), prot);
  477.   else
  478.     {
  479.       sizet bit;
  480.       switch TYP7
  481.     (scm_make_uve (0L, prot))
  482.     {
  483.     default:
  484.       bit = LONG_BIT;
  485.       break;
  486.     case tc7_bvect:
  487.       bit = 1;
  488.       break;
  489.     case tc7_string:
  490.       bit = CHAR_BIT;
  491.       break;
  492.     case tc7_fvect:
  493.       bit = sizeof (float) * CHAR_BIT / sizeof (char);
  494.       break;
  495.     case tc7_dvect:
  496.       bit = sizeof (double) * CHAR_BIT / sizeof (char);
  497.       break;
  498.     case tc7_cvect:
  499.       bit = 2 * sizeof (double) * CHAR_BIT / sizeof (char);
  500.       break;
  501.     }
  502.       ARRAY_BASE (ra) = (LONG_BIT + bit - 1) / bit;
  503.       rlen += ARRAY_BASE (ra);
  504.       ARRAY_V (ra) = scm_make_uve (rlen, prot);
  505.       *((long *) VELTS (ARRAY_V (ra))) = rlen;
  506.     }
  507.   if (NNULLP (fill))
  508.     {
  509.       ASSERT (1 == scm_ilength (fill), fill, WNA, s_dims2ura);
  510.       scm_array_fill (ra, CAR (fill));
  511.     }
  512.   else
  513.     scm_array_fill (ra, prot);
  514.   if (1 == ARRAY_NDIM (ra) && 0 == ARRAY_BASE (ra))
  515.     if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
  516.       return ARRAY_V (ra);
  517.   return ra;
  518. }
  519.  
  520. void 
  521. scm_ra_set_contp (ra)
  522.      SCM ra;
  523. {
  524.   sizet k = ARRAY_NDIM (ra);
  525.   long inc;
  526.   if (k)
  527.     inc = ARRAY_DIMS (ra)[k - 1].inc;
  528.   while (k--)
  529.     {
  530.       if (inc != ARRAY_DIMS (ra)[k].inc)
  531.     {
  532.       CAR (ra) &= ~ARRAY_CONTIGUOUS;
  533.       return;
  534.     }
  535.       inc *= (ARRAY_DIMS (ra)[k].ubnd - ARRAY_DIMS (ra)[k].lbnd + 1);
  536.     }
  537.   CAR (ra) |= ARRAY_CONTIGUOUS;
  538. }
  539. char scm_s_make_sh_array[] = "make-shared-array";
  540. SCM 
  541. scm_make_sh_array (oldra, mapfunc, dims)
  542.      SCM oldra;
  543.      SCM mapfunc;
  544.      SCM dims;
  545. {
  546.   SCM ra;
  547.   SCM inds, indptr;
  548.   SCM imap;
  549.   sizet i, k;
  550.   long old_min, new_min, old_max, new_max;
  551.   scm_array_dim *s;
  552.   ASSERT (BOOL_T == scm_procedurep (mapfunc), mapfunc, ARG2, scm_s_make_sh_array);
  553.   ASSERT (NIMP (oldra) && scm_arrayp (oldra, SCM_UNDEFINED), oldra, ARG1, scm_s_make_sh_array);
  554.   ra = scm_shap2ra (dims, scm_s_make_sh_array);
  555.   if (ARRAYP (oldra))
  556.     {
  557.       ARRAY_V (ra) = ARRAY_V (oldra);
  558.       old_min = old_max = ARRAY_BASE (oldra);
  559.       s = ARRAY_DIMS (oldra);
  560.       k = ARRAY_NDIM (oldra);
  561.       while (k--)
  562.     {
  563.       if (s[k].inc > 0)
  564.         old_max += (s[k].ubnd - s[k].lbnd) * s[k].inc;
  565.       else
  566.         old_min += (s[k].ubnd - s[k].lbnd) * s[k].inc;
  567.     }
  568.     }
  569.   else
  570.     {
  571.       ARRAY_V (ra) = oldra;
  572.       old_min = 0;
  573.       old_max = (long) LENGTH (oldra) - 1;
  574.     }
  575.   inds = EOL;
  576.   s = ARRAY_DIMS (ra);
  577.   for (k = 0; k < ARRAY_NDIM (ra); k++)
  578.     {
  579.       inds = scm_cons (MAKINUM (s[k].lbnd), inds);
  580.       if (s[k].ubnd < s[k].lbnd)
  581.     {
  582.       if (1 == ARRAY_NDIM (ra))
  583.         ra = scm_make_uve (0L, scm_array_prot (ra));
  584.       else
  585.         ARRAY_V (ra) = scm_make_uve (0L, scm_array_prot (ra));
  586.       return ra;
  587.     }
  588.     }
  589.   imap = scm_apply (mapfunc, scm_reverse (inds), EOL);
  590.   if (ARRAYP (oldra))
  591.  
  592.       i = (sizet) scm_aind (oldra, imap, scm_s_make_sh_array);
  593.   else
  594.     {
  595.       if (NINUMP (imap))
  596.  
  597.     {
  598.       ASSERT (1 == scm_ilength (imap) && INUMP (CAR (imap)),
  599.           imap, s_bad_ind, scm_s_make_sh_array);
  600.       imap = CAR (imap);
  601.     }
  602.       i = INUM (imap);
  603.     }
  604.   ARRAY_BASE (ra) = new_min = new_max = i;
  605.   indptr = inds;
  606.   k = ARRAY_NDIM (ra);
  607.   while (k--)
  608.     {
  609.       if (s[k].ubnd > s[k].lbnd)
  610.     {
  611.       CAR (indptr) = MAKINUM (INUM (CAR (indptr)) + 1);
  612.       imap = scm_apply (mapfunc, scm_reverse (inds), EOL);
  613.       if (ARRAYP (oldra))
  614.  
  615.           s[k].inc = scm_aind (oldra, imap, scm_s_make_sh_array) - i;
  616.       else
  617.         {
  618.           if (NINUMP (imap))
  619.  
  620.         {
  621.           ASSERT (1 == scm_ilength (imap) && INUMP (CAR (imap)),
  622.               imap, s_bad_ind, scm_s_make_sh_array);
  623.           imap = CAR (imap);
  624.         }
  625.           s[k].inc = (long) INUM (imap) - i;
  626.         }
  627.       i += s[k].inc;
  628.       if (s[k].inc > 0)
  629.         new_max += (s[k].ubnd - s[k].lbnd) * s[k].inc;
  630.       else
  631.         new_min += (s[k].ubnd - s[k].lbnd) * s[k].inc;
  632.     }
  633.       else
  634.     s[k].inc = new_max - new_min + 1;    /* contiguous by default */
  635.       indptr = CDR (indptr);
  636.     }
  637.   ASSERT (old_min <= new_min && old_max >= new_max, SCM_UNDEFINED,
  638.       "mapping out of range", scm_s_make_sh_array);
  639.   if (1 == ARRAY_NDIM (ra) && 0 == ARRAY_BASE (ra))
  640.     {
  641.       if (1 == s->inc && 0 == s->lbnd
  642.       && LENGTH (ARRAY_V (ra)) == 1 + s->ubnd)
  643.     return ARRAY_V (ra);
  644.       if (s->ubnd < s->lbnd)
  645.     return scm_make_uve (0L, scm_array_prot (ra));
  646.     }
  647.   scm_ra_set_contp (ra);
  648.   return ra;
  649. }
  650.  
  651. /* args are RA . DIMS */
  652. static char s_trans_array[] = "transpose-array";
  653. SCM 
  654. scm_trans_array (args)
  655.      SCM args;
  656. {
  657.   SCM ra, res, vargs, *ve = &vargs;
  658.   scm_array_dim *s, *r;
  659.   int ndim, i, k;
  660.   ASSERT (NIMP (args), SCM_UNDEFINED, WNA, s_trans_array);
  661.   ra = CAR (args);
  662.   args = CDR (args);
  663.   switch TYP7
  664.     (ra)
  665.     {
  666.     default:
  667.     badarg:scm_wta (ra, (char *) ARG1, s_trans_array);
  668.     case tc7_bvect:
  669.     case tc7_string:
  670.     case tc7_uvect:
  671.     case tc7_ivect:
  672.     case tc7_fvect:
  673.     case tc7_dvect:
  674.     case tc7_cvect:
  675.     case tc7_vector:
  676.       ASSERT (NIMP (args) && NULLP (CDR (args)), SCM_UNDEFINED, WNA, s_trans_array);
  677.       ASSERT (INUM0 == CAR (args), CAR (args), ARG1, s_trans_array);
  678.       return ra;
  679.     case tc7_smob:
  680.       ASRTGO (ARRAYP (ra), badarg);
  681.       vargs = scm_vector (args);
  682.       ASSERT (LENGTH (vargs) == ARRAY_NDIM (ra), SCM_UNDEFINED, WNA, s_trans_array);
  683.       ve = VELTS (vargs);
  684.       ndim = 0;
  685.       for (k = 0; k < ARRAY_NDIM (ra); k++)
  686.     {
  687.       i = INUM (ve[k]);
  688.       ASSERT (INUMP (ve[k]) && i >= 0 && i < ARRAY_NDIM (ra),
  689.           ve[k], ARG2, s_trans_array);
  690.       if (ndim < i)
  691.         ndim = i;
  692.     }
  693.       ndim++;
  694.       res = scm_make_ra (ndim);
  695.       ARRAY_V (res) = ARRAY_V (ra);
  696.       ARRAY_BASE (res) = ARRAY_BASE (ra);
  697.       for (k = ndim; k--;)
  698.     {
  699.       ARRAY_DIMS (res)[k].lbnd = 0;
  700.       ARRAY_DIMS (res)[k].ubnd = -1;
  701.     }
  702.       for (k = ARRAY_NDIM (ra); k--;)
  703.     {
  704.       i = INUM (ve[k]);
  705.       s = &(ARRAY_DIMS (ra)[k]);
  706.       r = &(ARRAY_DIMS (res)[i]);
  707.       if (r->ubnd < r->lbnd)
  708.         {
  709.           r->lbnd = s->lbnd;
  710.           r->ubnd = s->ubnd;
  711.           r->inc = s->inc;
  712.           ndim--;
  713.         }
  714.       else
  715.         {
  716.           if (r->ubnd > s->ubnd)
  717.         r->ubnd = s->ubnd;
  718.           if (r->lbnd < s->lbnd)
  719.         {
  720.           ARRAY_BASE (res) += (s->lbnd - r->lbnd) * r->inc;
  721.           r->lbnd = s->lbnd;
  722.         }
  723.           r->inc += s->inc;
  724.         }
  725.     }
  726.       ASSERT (ndim <= 0, args, "bad argument scm_list", s_trans_array);
  727.       scm_ra_set_contp (res);
  728.       return res;
  729.     }
  730. }
  731.  
  732. /* args are RA . AXES */
  733. static char s_encl_array[] = "enclose-array";
  734. SCM 
  735. scm_encl_array (axes)
  736.      SCM axes;
  737. {
  738.   SCM axv, ra, res, ra_inr;
  739.   scm_array_dim vdim, *s = &vdim;
  740.   int ndim, j, k, ninr, noutr;
  741.   ASSERT (NIMP (axes), SCM_UNDEFINED, WNA, s_encl_array);
  742.   ra = CAR (axes);
  743.   axes = CDR (axes);
  744.   if (NULLP (axes))
  745.  
  746.       axes = scm_cons ((ARRAYP (ra) ? MAKINUM (ARRAY_NDIM (ra) - 1) : INUM0), EOL);
  747.   ninr = scm_ilength (axes);
  748.   ra_inr = scm_make_ra (ninr);
  749.   ASRTGO (NIMP (ra), badarg1);
  750.   switch TYP7
  751.     (ra)
  752.     {
  753.     default:
  754.     badarg1:scm_wta (ra, (char *) ARG1, s_encl_array);
  755.     case tc7_string:
  756.     case tc7_bvect:
  757.     case tc7_uvect:
  758.     case tc7_ivect:
  759.     case tc7_fvect:
  760.     case tc7_dvect:
  761.     case tc7_cvect:
  762.     case tc7_vector:
  763.       s->lbnd = 0;
  764.       s->ubnd = LENGTH (ra) - 1;
  765.       s->inc = 1;
  766.       ARRAY_V (ra_inr) = ra;
  767.       ARRAY_BASE (ra_inr) = 0;
  768.       ndim = 1;
  769.       break;
  770.     case tc7_smob:
  771.       ASRTGO (ARRAYP (ra), badarg1);
  772.       s = ARRAY_DIMS (ra);
  773.       ARRAY_V (ra_inr) = ARRAY_V (ra);
  774.       ARRAY_BASE (ra_inr) = ARRAY_BASE (ra);
  775.       ndim = ARRAY_NDIM (ra);
  776.       break;
  777.     }
  778.   noutr = ndim - ninr;
  779.   axv = scm_make_string (MAKINUM (ndim), MAKICHR (0));
  780.   ASSERT (0 <= noutr && 0 <= ninr, SCM_UNDEFINED, WNA, s_encl_array);
  781.   res = scm_make_ra (noutr);
  782.   ARRAY_BASE (res) = ARRAY_BASE (ra_inr);
  783.   ARRAY_V (res) = ra_inr;
  784.   for (k = 0; k < ninr; k++, axes = CDR (axes))
  785.     {
  786.       ASSERT (INUMP (CAR (axes)), CAR (axes), "bad axis", s_encl_array);
  787.       j = INUM (CAR (axes));
  788.       ARRAY_DIMS (ra_inr)[k].lbnd = s[j].lbnd;
  789.       ARRAY_DIMS (ra_inr)[k].ubnd = s[j].ubnd;
  790.       ARRAY_DIMS (ra_inr)[k].inc = s[j].inc;
  791.       CHARS (axv)[j] = 1;
  792.     }
  793.   for (j = 0, k = 0; k < noutr; k++, j++)
  794.     {
  795.       while (CHARS (axv)[j])
  796.     j++;
  797.       ARRAY_DIMS (res)[k].lbnd = s[j].lbnd;
  798.       ARRAY_DIMS (res)[k].ubnd = s[j].ubnd;
  799.       ARRAY_DIMS (res)[k].inc = s[j].inc;
  800.     }
  801.   scm_ra_set_contp (ra_inr);
  802.   scm_ra_set_contp (res);
  803.   return res;
  804. }
  805.  
  806. static char s_array_inbp[] = "array-in-bounds?";
  807. SCM 
  808. scm_array_inbp (args)
  809.      SCM args;
  810. {
  811.   SCM v, ind = EOL;
  812.   long pos = 0;
  813.   register sizet k;
  814.   register long j;
  815.   scm_array_dim *s;
  816.   ASSERT (NIMP (args), args, WNA, s_array_inbp);
  817.   v = CAR (args);
  818.   args = CDR (args);
  819.   ASRTGO (NIMP (v), badarg1);
  820.   if (NIMP (args))
  821.  
  822.     {
  823.       ind = CAR (args);
  824.       args = CDR (args);
  825.       ASSERT (INUMP (ind), ind, ARG2, s_array_inbp);
  826.       pos = INUM (ind);
  827.     }
  828. tail:
  829.   switch TYP7
  830.     (v)
  831.     {
  832.     default:
  833.     badarg1:scm_wta (v, (char *) ARG1, s_array_inbp);
  834.     wna:scm_wta (args, (char *) WNA, s_array_inbp);
  835.     case tc7_smob:
  836.       k = ARRAY_NDIM (v);
  837.       s = ARRAY_DIMS (v);
  838.       pos = ARRAY_BASE (v);
  839.       if (!k)
  840.     {
  841.       ASRTGO (NULLP (ind), wna);
  842.       ind = INUM0;
  843.     }
  844.       else
  845.     while (!0)
  846.       {
  847.         j = INUM (ind);
  848.         if (!(j >= (s->lbnd) && j <= (s->ubnd)))
  849.           {
  850.         ASRTGO (--k == scm_ilength (args), wna);
  851.         return BOOL_F;
  852.           }
  853.         pos += (j - s->lbnd) * (s->inc);
  854.         if (!(--k && NIMP (args)))
  855.           break;
  856.         ind = CAR (args);
  857.         args = CDR (args);
  858.         s++;
  859.         ASSERT (INUMP (ind), ind, s_bad_ind, s_array_inbp);
  860.       }
  861.       ASRTGO (0 == k, wna);
  862.       v = ARRAY_V (v);
  863.       goto tail;
  864.     case tc7_bvect:
  865.     case tc7_string:
  866.     case tc7_uvect:
  867.     case tc7_ivect:
  868.     case tc7_fvect:
  869.     case tc7_dvect:
  870.     case tc7_cvect:
  871.     case tc7_vector:
  872.       ASRTGO (NULLP (args) && INUMP (ind), wna);
  873.       return pos >= 0 && pos < LENGTH (v) ? BOOL_T : BOOL_F;
  874.     }
  875. }
  876. static char s_aref[] = "array-ref";
  877. SCM 
  878. scm_aref (v, args)
  879.      SCM v, args;
  880. {
  881.   long pos;
  882.   if (IMP (v))
  883.  
  884.     {
  885.       ASRTGO (NULLP (args), badarg);
  886.       return v;
  887.     }
  888.   else if (ARRAYP (v))
  889.  
  890.     {
  891.       pos = scm_aind (v, args, s_aref);
  892.       v = ARRAY_V (v);
  893.     }
  894.   else
  895.     {
  896.       if (NIMP (args))
  897.  
  898.     {
  899.       ASSERT (CONSP (args) && INUMP (CAR (args)), args, ARG2, s_aref);
  900.       pos = INUM (CAR (args));
  901.       ASRTGO (NULLP (CDR (args)), wna);
  902.     }
  903.       else
  904.     {
  905.       ASSERT (INUMP (args), args, ARG2, s_aref);
  906.       pos = INUM (args);
  907.     }
  908.       ASRTGO (pos >= 0 && pos < LENGTH (v), outrng);
  909.     }
  910.   switch TYP7
  911.     (v)
  912.     {
  913.     default:
  914.       if (NULLP (args))
  915.  return v;
  916.     badarg:scm_wta (v, (char *) ARG1, s_aref);
  917.     outrng:scm_wta (MAKINUM (pos), (char *) OUTOFRANGE, s_aref);
  918.     wna:scm_wta (SCM_UNDEFINED, (char *) WNA, s_aref);
  919.     case tc7_smob:
  920.       {                /* enclosed */
  921.     int k = ARRAY_NDIM (v);
  922.     SCM res = scm_make_ra (k);
  923.     ARRAY_V (res) = ARRAY_V (v);
  924.     ARRAY_BASE (res) = pos;
  925.     while (k--)
  926.       {
  927.         ARRAY_DIMS (res)[k].lbnd = ARRAY_DIMS (v)[k].lbnd;
  928.         ARRAY_DIMS (res)[k].ubnd = ARRAY_DIMS (v)[k].ubnd;
  929.         ARRAY_DIMS (res)[k].inc = ARRAY_DIMS (v)[k].inc;
  930.       }
  931.     return res;
  932.       }
  933.     case tc7_bvect:
  934.       if (VELTS (v)[pos / LONG_BIT] & (1L << (pos % LONG_BIT)))
  935.     return BOOL_T;
  936.       else
  937.     return BOOL_F;
  938.     case tc7_string:
  939.       return MAKICHR (CHARS (v)[pos]);
  940. # ifdef INUMS_ONLY
  941.     case tc7_uvect:
  942.     case tc7_ivect:
  943.       return MAKINUM (VELTS (v)[pos]);
  944. # else
  945.   case tc7_uvect:
  946.     return scm_ulong2num(VELTS(v)[pos]);
  947.   case tc7_ivect:
  948.     return long2num(VELTS(v)[pos]);
  949. # endif    
  950. #ifdef FLOATS
  951. #ifdef SINGLES
  952.     case tc7_fvect:
  953.       return makflo (((float *) CDR (v))[pos]);
  954. #endif
  955.     case tc7_dvect:
  956.       return scm_makdbl (((double *) CDR (v))[pos], 0.0);
  957.     case tc7_cvect:
  958.       return scm_makdbl (((double *) CDR (v))[2 * pos],
  959.              ((double *) CDR (v))[2 * pos + 1]);
  960. #endif
  961.     case tc7_vector:
  962.       return VELTS (v)[pos];
  963.     }
  964. }
  965. SCM 
  966. scm_array_ref (args)
  967.      SCM args;
  968. {
  969.   ASSERT (NIMP (args), SCM_UNDEFINED, WNA, s_aref);
  970.   return scm_aref (CAR (args), CDR (args));
  971. }
  972.  
  973. /* Internal version of scm_aref for uves that does no error checking and
  974.    tries to recycle conses.  (Make *sure* you want them recycled.) */
  975. SCM 
  976. scm_cvref (v, pos, last)
  977.      SCM v;
  978.      sizet pos;
  979.      SCM last;
  980. {
  981.   switch TYP7
  982.     (v)
  983.     {
  984.     default:
  985.       scm_wta (v, (char *) ARG1, "PROGRAMMING ERROR: scm_cvref");
  986.     case tc7_bvect:
  987.       if (VELTS (v)[pos / LONG_BIT] & (1L << (pos % LONG_BIT)))
  988.     return BOOL_T;
  989.       else
  990.     return BOOL_F;
  991.     case tc7_string:
  992.       return MAKICHR (CHARS (v)[pos]);
  993. # ifdef INUMS_ONLY
  994.     case tc7_uvect:
  995.     case tc7_ivect:
  996.       return MAKINUM (VELTS (v)[pos]);
  997. # else
  998.     case tc7_uvect:
  999.       return scm_ulong2num(VELTS(v)[pos]);
  1000.     case tc7_ivect:
  1001.       return long2num(VELTS(v)[pos]);
  1002. # endif    
  1003. #ifdef FLOATS
  1004. #ifdef SINGLES
  1005.     case tc7_fvect:
  1006.       if (NIMP (last) && (last != flo0) && (tc_flo == CAR (last)))
  1007.     {
  1008.       FLO (last) = ((float *) CDR (v))[pos];
  1009.       return last;
  1010.     }
  1011.       return makflo (((float *) CDR (v))[pos]);
  1012. #endif
  1013.     case tc7_dvect:
  1014. #ifdef SINGLES
  1015.       if (NIMP (last) && tc_dblr == CAR (last))
  1016. #else
  1017.       if (NIMP (last) && (last != flo0) && (tc_dblr == CAR (last)))
  1018. #endif
  1019.     {
  1020.       REAL (last) = ((double *) CDR (v))[pos];
  1021.       return last;
  1022.     }
  1023.       return scm_makdbl (((double *) CDR (v))[pos], 0.0);
  1024.     case tc7_cvect:
  1025.       if (NIMP (last) && tc_dblc == CAR (last))
  1026.     {
  1027.       REAL (last) = ((double *) CDR (v))[2 * pos];
  1028.       IMAG (last) = ((double *) CDR (v))[2 * pos + 1];
  1029.       return last;
  1030.     }
  1031.       return scm_makdbl (((double *) CDR (v))[2 * pos],
  1032.              ((double *) CDR (v))[2 * pos + 1]);
  1033. #endif
  1034.     case tc7_vector:
  1035.       return VELTS (v)[pos];
  1036.     case tc7_smob:
  1037.       {                /* enclosed scm_array */
  1038.     int k = ARRAY_NDIM (v);
  1039.     SCM res = scm_make_ra (k);
  1040.     ARRAY_V (res) = ARRAY_V (v);
  1041.     ARRAY_BASE (res) = pos;
  1042.     while (k--)
  1043.       {
  1044.         ARRAY_DIMS (res)[k].ubnd = ARRAY_DIMS (v)[k].ubnd;
  1045.         ARRAY_DIMS (res)[k].lbnd = ARRAY_DIMS (v)[k].lbnd;
  1046.         ARRAY_DIMS (res)[k].inc = ARRAY_DIMS (v)[k].inc;
  1047.       }
  1048.     return res;
  1049.       }
  1050.     }
  1051. }
  1052.  
  1053. static char s_aset[] = "array-set!";
  1054. SCM 
  1055. scm_aset (v, obj, args)
  1056.      SCM v, obj, args;
  1057. {
  1058.   long pos;
  1059.   ASRTGO (NIMP (v), badarg1);
  1060.   if (ARRAYP (v))
  1061.  
  1062.     {
  1063.       pos = scm_aind (v, args, s_aset);
  1064.       v = ARRAY_V (v);
  1065.     }
  1066.   else
  1067.     {
  1068.       if (NIMP (args))
  1069.  
  1070.     {
  1071.       ASSERT (CONSP (args) && INUMP (CAR (args)), args, ARG2, s_aset);
  1072.       pos = INUM (CAR (args));
  1073.       ASRTGO (NULLP (CDR (args)), wna);
  1074.     }
  1075.       else
  1076.     {
  1077.       ASSERT (INUMP (args), args, ARG2, s_aset);
  1078.       pos = INUM (args);
  1079.     }
  1080.       ASRTGO (pos >= 0 && pos < LENGTH (v), outrng);
  1081.     }
  1082.   switch TYP7
  1083.     (v)
  1084.     {
  1085.     default:
  1086.     badarg1:scm_wta (v, (char *) ARG1, s_aset);
  1087.     outrng:scm_wta (MAKINUM (pos), (char *) OUTOFRANGE, s_aset);
  1088.     wna:scm_wta (SCM_UNDEFINED, (char *) WNA, s_aset);
  1089.     case tc7_smob:        /* enclosed */
  1090.       goto badarg1;
  1091.     case tc7_bvect:
  1092.       if (BOOL_F == obj)
  1093.     VELTS (v)[pos / LONG_BIT] &= ~(1L << (pos % LONG_BIT));
  1094.       else if (BOOL_T == obj)
  1095.     VELTS (v)[pos / LONG_BIT] |= (1L << (pos % LONG_BIT));
  1096.       else
  1097.       badarg3:scm_wta (obj, (char *) ARG3, s_aset);
  1098.       break;
  1099.     case tc7_string:
  1100.       ASRTGO (ICHRP (obj), badarg3);
  1101.       CHARS (v)[pos] = ICHR (obj);
  1102.       break;
  1103. # ifdef INUMS_ONLY
  1104.     case tc7_uvect:
  1105.       ASRTGO (INUM (obj) >= 0, badarg3);
  1106.     case tc7_ivect:
  1107.     ASRTGO(INUMP(obj), badarg3); VELTS(v)[pos] = INUM(obj); break;
  1108. # else
  1109.   case tc7_uvect:
  1110.     VELTS(v)[pos] = scm_num2ulong(obj, (char *)ARG3, s_aset); break;
  1111.   case tc7_ivect:
  1112.     VELTS(v)[pos] = num2long(obj, (char *)ARG3, s_aset); break;
  1113. # endif
  1114.       break;
  1115. #ifdef FLOATS
  1116. #ifdef SINGLES
  1117.     case tc7_fvect:
  1118.       ASRTGO (NIMP (obj) && REALP (obj), badarg3);
  1119.       ((float *) CDR (v))[pos] = REALPART (obj);
  1120.       break;
  1121. #endif
  1122.     case tc7_dvect:
  1123.       ASRTGO (NIMP (obj) && REALP (obj), badarg3);
  1124.       ((double *) CDR (v))[pos] = REALPART (obj);
  1125.       break;
  1126.     case tc7_cvect:
  1127.       ASRTGO (NIMP (obj) && INEXP (obj), badarg3);
  1128.       ((double *) CDR (v))[2 * pos] = REALPART (obj);
  1129.       ((double *) CDR (v))[2 * pos + 1] = CPLXP (obj) ? IMAG (obj) : 0.0;
  1130.       break;
  1131. #endif
  1132.     case tc7_vector:
  1133.       VELTS (v)[pos] = obj;
  1134.       break;
  1135.     }
  1136.   return UNSPECIFIED;
  1137. }
  1138.  
  1139. static char s_array_contents[] = "array-contents";
  1140. SCM 
  1141. scm_array_contents (ra, strict)
  1142.      SCM ra, strict;
  1143. {
  1144.   SCM sra;
  1145.   if (IMP (ra))
  1146.  return BOOL_F;
  1147.   switch TYP7
  1148.     (ra)
  1149.     {
  1150.     default:
  1151.       return BOOL_F;
  1152.     case tc7_vector:
  1153.     case tc7_string:
  1154.     case tc7_bvect:
  1155.     case tc7_uvect:
  1156.     case tc7_ivect:
  1157.     case tc7_fvect:
  1158.     case tc7_dvect:
  1159.     case tc7_cvect:
  1160.       return ra;
  1161.     case tc7_smob:
  1162.       {
  1163.     sizet k, ndim = ARRAY_NDIM (ra), len = 1;
  1164.     if (!ARRAYP (ra) || !ARRAY_CONTP (ra))
  1165.       return BOOL_F;
  1166.     for (k = 0; k < ndim; k++)
  1167.       len *= ARRAY_DIMS (ra)[k].ubnd - ARRAY_DIMS (ra)[k].lbnd + 1;
  1168.     if (!UNBNDP (strict))
  1169.       {
  1170.         if ARRAY_BASE
  1171.           (ra) return BOOL_F;
  1172.         if (ndim && (1 != ARRAY_DIMS (ra)[ndim - 1].inc))
  1173.           return BOOL_F;
  1174.         if (tc7_bvect == TYP7 (ARRAY_V (ra)))
  1175.           {
  1176.         if (len != LENGTH (ARRAY_V (ra)) ||
  1177.             ARRAY_BASE (ra) % LONG_BIT ||
  1178.             len % LONG_BIT)
  1179.           return BOOL_F;
  1180.           }
  1181.       }
  1182.     if ((len == LENGTH (ARRAY_V (ra))) && 0 == ARRAY_BASE (ra) && ARRAY_DIMS (ra)->inc)
  1183.       return ARRAY_V (ra);
  1184.     sra = scm_make_ra (1);
  1185.     ARRAY_DIMS (sra)->lbnd = 0;
  1186.     ARRAY_DIMS (sra)->ubnd = len - 1;
  1187.     ARRAY_V (sra) = ARRAY_V (ra);
  1188.     ARRAY_BASE (sra) = ARRAY_BASE (ra);
  1189.     ARRAY_DIMS (sra)->inc = (ndim ? ARRAY_DIMS (ra)[ndim - 1].inc : 1);
  1190.     return sra;
  1191.       }
  1192.     }
  1193. }
  1194. SCM scm_array_copy P ((SCM src, SCM dst));
  1195. SCM 
  1196. scm_ra2contig (ra, copy)
  1197.      SCM ra;
  1198.      int copy;
  1199. {
  1200.   SCM ret;
  1201.   long inc = 1;
  1202.   sizet k, len = 1;
  1203.   for (k = ARRAY_NDIM (ra); k--;)
  1204.     len *= ARRAY_DIMS (ra)[k].ubnd - ARRAY_DIMS (ra)[k].lbnd + 1;
  1205.   k = ARRAY_NDIM (ra);
  1206.   if (ARRAY_CONTP (ra) && ((0 == k) || (1 == ARRAY_DIMS (ra)[k - 1].inc)))
  1207.     {
  1208.       if (tc7_bvect != TYP7 (ra))
  1209.     return ra;
  1210.       if ((len == LENGTH (ARRAY_V (ra)) &&
  1211.        0 == ARRAY_BASE (ra) % LONG_BIT &&
  1212.        0 == len % LONG_BIT))
  1213.     return ra;
  1214.     }
  1215.   ret = scm_make_ra (k);
  1216.   ARRAY_BASE (ret) = 0;
  1217.   while (k--)
  1218.     {
  1219.       ARRAY_DIMS (ret)[k].lbnd = ARRAY_DIMS (ra)[k].lbnd;
  1220.       ARRAY_DIMS (ret)[k].ubnd = ARRAY_DIMS (ra)[k].ubnd;
  1221.       ARRAY_DIMS (ret)[k].inc = inc;
  1222.       inc *= ARRAY_DIMS (ra)[k].ubnd - ARRAY_DIMS (ra)[k].lbnd + 1;
  1223.     }
  1224.   ARRAY_V (ret) = scm_make_uve ((inc - 1), scm_array_prot (ra));
  1225.   if (copy)
  1226.     scm_array_copy (ra, ret);
  1227.   return ret;
  1228. }
  1229. static char s_ura_rd[] = "uniform-array-read!";
  1230. SCM 
  1231. scm_ura_read (ra, port)
  1232.      SCM ra, port;
  1233. {
  1234.   SCM cra, v = ra;
  1235.   long sz, len, ans;
  1236.   long start = 0;
  1237.   if (UNBNDP (port))
  1238.  port = cur_inp;
  1239.   else
  1240.     ASSERT (NIMP (port) && OPINFPORTP (port), port, ARG2, s_ura_rd);
  1241.   ASRTGO (NIMP (v), badarg1);
  1242.   len = LENGTH (v);
  1243. loop:
  1244.   switch TYP7
  1245.     (v)
  1246.     {
  1247.     default:
  1248.     badarg1:scm_wta (v, (char *) ARG1, s_ura_rd);
  1249.     case tc7_smob:
  1250.       ASRTGO (ARRAYP (v), badarg1);
  1251.       cra = scm_ra2contig (ra, 0);
  1252.       start = ARRAY_BASE (cra);
  1253.       len = ARRAY_DIMS (cra)->inc *
  1254.     (ARRAY_DIMS (cra)->ubnd - ARRAY_DIMS (cra)->lbnd + 1);
  1255.       v = ARRAY_V (cra);
  1256.       goto loop;
  1257.     case tc7_string:
  1258.       sz = sizeof (char);
  1259.       break;
  1260.     case tc7_bvect:
  1261.       len = (len + LONG_BIT - 1) / LONG_BIT;
  1262.       start /= LONG_BIT;
  1263.     case tc7_uvect:
  1264.     case tc7_ivect:
  1265.       sz = sizeof (long);
  1266.       break;
  1267. #ifdef FLOATS
  1268. #ifdef SINGLES
  1269.     case tc7_fvect:
  1270.       sz = sizeof (float);
  1271.       break;
  1272. #endif
  1273.     case tc7_dvect:
  1274.       sz = sizeof (double);
  1275.       break;
  1276.     case tc7_cvect:
  1277.       sz = 2 * sizeof (double);
  1278.       break;
  1279. #endif
  1280.     }
  1281.   /* An ungetc before an fread will not work on some systems if setbuf(0).
  1282.      do #define NOSETBUF in scmfig.h to fix this. */
  1283.   if (CRDYP (port))
  1284.  
  1285.     {                /* UGGH!!! */
  1286.       ungetc (CGETUN (port), STREAM (port));
  1287.       CLRDY (port);        /* Clear ungetted char */
  1288.     }
  1289.   SYSCALL (ans = fread (CHARS (v) + start * sz, (sizet) sz, (sizet) len, STREAM (port)));
  1290.   if (TYP7 (v) == tc7_bvect)
  1291.     ans *= LONG_BIT;
  1292.   if (v != ra && cra != ra)
  1293.     scm_array_copy (cra, ra);
  1294.   return MAKINUM (ans);
  1295. }
  1296.  
  1297. static char s_ura_wr[] = "uniform-array-write";
  1298. SCM 
  1299. scm_ura_write (v, port)
  1300.      SCM v, port;
  1301. {
  1302.   long sz, len, ans;
  1303.   long start = 0;
  1304.   if (UNBNDP (port))
  1305.  port = cur_outp;
  1306.   else
  1307.     ASSERT (NIMP (port) && OPOUTFPORTP (port), port, ARG2, s_ura_wr);
  1308.   ASRTGO (NIMP (v), badarg1);
  1309.   len = LENGTH (v);
  1310. loop:
  1311.   switch TYP7
  1312.     (v)
  1313.     {
  1314.     default:
  1315.     badarg1:scm_wta (v, (char *) ARG1, s_ura_wr);
  1316.     case tc7_smob:
  1317.       ASRTGO (ARRAYP (v), badarg1);
  1318.       v = scm_ra2contig (v, 1);
  1319.       start = ARRAY_BASE (v);
  1320.       len = ARRAY_DIMS (v)->inc * (ARRAY_DIMS (v)->ubnd - ARRAY_DIMS (v)->lbnd + 1);
  1321.       v = ARRAY_V (v);
  1322.       goto loop;
  1323.     case tc7_string:
  1324.       sz = sizeof (char);
  1325.       break;
  1326.     case tc7_bvect:
  1327.       len = (len + LONG_BIT - 1) / LONG_BIT;
  1328.       start /= LONG_BIT;
  1329.     case tc7_uvect:
  1330.     case tc7_ivect:
  1331.       sz = sizeof (long);
  1332.       break;
  1333. #ifdef FLOATS
  1334. #ifdef SINGLES
  1335.     case tc7_fvect:
  1336.       sz = sizeof (float);
  1337.       break;
  1338. #endif
  1339.     case tc7_dvect:
  1340.       sz = sizeof (double);
  1341.       break;
  1342.     case tc7_cvect:
  1343.       sz = 2 * sizeof (double);
  1344.       break;
  1345. #endif
  1346.     }
  1347.   SYSCALL (ans = fwrite (CHARS (v) + start * sz, (sizet) sz, (sizet) len, STREAM (port)));
  1348.   if (TYP7 (v) == tc7_bvect)
  1349.     ans *= LONG_BIT;
  1350.   return MAKINUM (ans);
  1351. }
  1352.  
  1353. static char cnt_tab[16] =
  1354. {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
  1355. static char s_count[] = "bit-count";
  1356. SCM 
  1357. scm_lcount (item, seq)
  1358.      SCM item, seq;
  1359. {
  1360.   long i;
  1361.   register unsigned long cnt = 0, w;
  1362.   ASSERT (NIMP (seq), seq, ARG2, s_count);
  1363.   switch TYP7
  1364.     (seq)
  1365.     {
  1366.     default:
  1367.       scm_wta (seq, (char *) ARG2, s_count);
  1368.     case tc7_bvect:
  1369.       if (0 == LENGTH (seq))
  1370.     return INUM0;
  1371.       i = (LENGTH (seq) - 1) / LONG_BIT;
  1372.       w = VELTS (seq)[i];
  1373.       if (FALSEP (item))
  1374.  w = ~w;
  1375.       w <<= LONG_BIT - 1 - ((LENGTH (seq) - 1) % LONG_BIT);
  1376.       while (!0)
  1377.     {
  1378.       for (; w; w >>= 4)
  1379.         cnt += cnt_tab[w & 0x0f];
  1380.       if (0 == i--)
  1381.         return MAKINUM (cnt);
  1382.       w = VELTS (seq)[i];
  1383.       if (FALSEP (item))
  1384.  w = ~w;
  1385.     }
  1386.     }
  1387. }
  1388. static char s_uve_pos[] = "bit-position";
  1389. SCM 
  1390. scm_position (item, v, k)
  1391.      SCM item, v, k;
  1392. {
  1393.   long i, lenw, xbits, pos = INUM (k);
  1394.   register unsigned long w;
  1395.   ASSERT (NIMP (v), v, ARG2, s_uve_pos);
  1396.   ASSERT (INUMP (k), k, ARG3, s_uve_pos);
  1397.   ASSERT ((pos <= LENGTH (v)) && (pos >= 0),
  1398.       k, OUTOFRANGE, s_uve_pos);
  1399.   if (pos == LENGTH (v))
  1400.     return BOOL_F;
  1401.   switch TYP7
  1402.     (v)
  1403.     {
  1404.     default:
  1405.       scm_wta (v, (char *) ARG2, s_uve_pos);
  1406.     case tc7_bvect:
  1407.       if (0 == LENGTH (v))
  1408.     return MAKINUM (-1L);
  1409.       lenw = (LENGTH (v) - 1) / LONG_BIT;    /* watch for part words */
  1410.       i = pos / LONG_BIT;
  1411.       w = VELTS (v)[i];
  1412.       if (FALSEP (item))
  1413.  w = ~w;
  1414.       xbits = (pos % LONG_BIT);
  1415.       pos -= xbits;
  1416.       w = ((w >> xbits) << xbits);
  1417.       xbits = LONG_BIT - 1 - (LENGTH (v) - 1) % LONG_BIT;
  1418.       while (!0)
  1419.     {
  1420.       if (w && (i == lenw))
  1421.         w = ((w << xbits) >> xbits);
  1422.       if (w)
  1423.         while (w)
  1424.           switch (w & 0x0f)
  1425.         {
  1426.         default:
  1427.           return MAKINUM (pos);
  1428.         case 2:
  1429.         case 6:
  1430.         case 10:
  1431.         case 14:
  1432.           return MAKINUM (pos + 1);
  1433.         case 4:
  1434.         case 12:
  1435.           return MAKINUM (pos + 2);
  1436.         case 8:
  1437.           return MAKINUM (pos + 3);
  1438.         case 0:
  1439.           pos += 4;
  1440.           w >>= 4;
  1441.         }
  1442.       if (++i > lenw)
  1443.         break;
  1444.       pos += LONG_BIT;
  1445.       w = VELTS (v)[i];
  1446.       if (FALSEP (item))
  1447.  w = ~w;
  1448.     }
  1449.       return BOOL_F;
  1450.     }
  1451. }
  1452.  
  1453. static char s_bit_set[] = "bit-set*!";
  1454. SCM 
  1455. scm_bit_set (v, kv, obj)
  1456.      SCM v, kv, obj;
  1457. {
  1458.   register long i, k, vlen;
  1459.   ASRTGO (NIMP (v), badarg1);
  1460.   ASRTGO (NIMP (kv), badarg2);
  1461.   switch TYP7
  1462.     (kv)
  1463.     {
  1464.     default:
  1465.     badarg2:scm_wta (kv, (char *) ARG2, s_bit_set);
  1466.     case tc7_uvect:
  1467.       switch TYP7
  1468.     (v)
  1469.     {
  1470.     default:
  1471.     badarg1:scm_wta (v, (char *) ARG1, s_bit_set);
  1472.     case tc7_bvect:
  1473.       vlen = LENGTH (v);
  1474.       if (BOOL_F == obj)
  1475.         for (i = LENGTH (kv); i;)
  1476.           {
  1477.         k = VELTS (kv)[--i];
  1478.         ASSERT ((k < vlen), MAKINUM (k), OUTOFRANGE, s_bit_set);
  1479.         VELTS (v)[k / LONG_BIT] &= ~(1L << (k % LONG_BIT));
  1480.           }
  1481.       else if (BOOL_T == obj)
  1482.         for (i = LENGTH (kv); i;)
  1483.           {
  1484.         k = VELTS (kv)[--i];
  1485.         ASSERT ((k < vlen), MAKINUM (k), OUTOFRANGE, s_bit_set);
  1486.         VELTS (v)[k / LONG_BIT] |= (1L << (k % LONG_BIT));
  1487.           }
  1488.       else
  1489.       badarg3:scm_wta (obj, (char *) ARG3, s_bit_set);
  1490.     }
  1491.       break;
  1492.     case tc7_bvect:
  1493.       ASRTGO (TYP7 (v) == tc7_bvect && LENGTH (v) == LENGTH (kv), badarg1);
  1494.       if (BOOL_F == obj)
  1495.     for (k = (LENGTH (v) + LONG_BIT - 1) / LONG_BIT; k--;)
  1496.       VELTS (v)[k] &= ~(VELTS (kv)[k]);
  1497.       else if (BOOL_T == obj)
  1498.     for (k = (LENGTH (v) + LONG_BIT - 1) / LONG_BIT; k--;)
  1499.       VELTS (v)[k] |= VELTS (kv)[k];
  1500.       else
  1501.     goto badarg3;
  1502.       break;
  1503.     }
  1504.   return UNSPECIFIED;
  1505. }
  1506.  
  1507. static char s_bit_count[] = "bit-count*";
  1508. SCM 
  1509. scm_bit_count (v, kv, obj)
  1510.      SCM v, kv, obj;
  1511. {
  1512.   register long i, vlen, count = 0;
  1513.   register unsigned long k;
  1514.   ASRTGO (NIMP (v), badarg1);
  1515.   ASRTGO (NIMP (kv), badarg2);
  1516.   switch TYP7
  1517.     (kv)
  1518.     {
  1519.     default:
  1520.     badarg2:scm_wta (kv, (char *) ARG2, s_bit_count);
  1521.     case tc7_uvect:
  1522.       switch TYP7
  1523.     (v)
  1524.     {
  1525.     default:
  1526.     badarg1:scm_wta (v, (char *) ARG1, s_bit_count);
  1527.     case tc7_bvect:
  1528.       vlen = LENGTH (v);
  1529.       if (BOOL_F == obj)
  1530.         for (i = LENGTH (kv); i;)
  1531.           {
  1532.         k = VELTS (kv)[--i];
  1533.         ASSERT ((k < vlen), MAKINUM (k), OUTOFRANGE, s_bit_count);
  1534.         if (!(VELTS (v)[k / LONG_BIT] & (1L << (k % LONG_BIT))))
  1535.           count++;
  1536.           }
  1537.       else if (BOOL_T == obj)
  1538.         for (i = LENGTH (kv); i;)
  1539.           {
  1540.         k = VELTS (kv)[--i];
  1541.         ASSERT ((k < vlen), MAKINUM (k), OUTOFRANGE, s_bit_count);
  1542.         if (VELTS (v)[k / LONG_BIT] & (1L << (k % LONG_BIT)))
  1543.           count++;
  1544.           }
  1545.       else
  1546.       badarg3:scm_wta (obj, (char *) ARG3, s_bit_count);
  1547.     }
  1548.       break;
  1549.     case tc7_bvect:
  1550.       ASRTGO (TYP7 (v) == tc7_bvect && LENGTH (v) == LENGTH (kv), badarg1);
  1551.       if (0 == LENGTH (v))
  1552.     return INUM0;
  1553.       ASRTGO (BOOL_T == obj || BOOL_F == obj, badarg3);
  1554.       obj = (BOOL_T == obj);
  1555.       i = (LENGTH (v) - 1) / LONG_BIT;
  1556.       k = VELTS (kv)[i] & (obj ? VELTS (v)[i] : ~VELTS (v)[i]);
  1557.       k <<= LONG_BIT - 1 - ((LENGTH (v) - 1) % LONG_BIT);
  1558.       while (!0)
  1559.     {
  1560.       for (; k; k >>= 4)
  1561.         count += cnt_tab[k & 0x0f];
  1562.       if (0 == i--)
  1563.         return MAKINUM (count);
  1564.       k = VELTS (kv)[i] & (obj ? VELTS (v)[i] : ~VELTS (v)[i]);
  1565.     }
  1566.     }
  1567.   return MAKINUM (count);
  1568. }
  1569.  
  1570. static char s_bit_inv[] = "bit-invert!";
  1571. SCM 
  1572. scm_bit_inv (v)
  1573.      SCM v;
  1574. {
  1575.   register long k;
  1576.   ASRTGO (NIMP (v), badarg1);
  1577.   k = LENGTH (v);
  1578.   switch TYP7
  1579.     (v)
  1580.     {
  1581.     case tc7_bvect:
  1582.       for (k = (k + LONG_BIT - 1) / LONG_BIT; k--;)
  1583.     VELTS (v)[k] = ~VELTS (v)[k];
  1584.       break;
  1585.     default:
  1586.     badarg1:scm_wta (v, (char *) ARG1, s_bit_inv);
  1587.     }
  1588.   return UNSPECIFIED;
  1589. }
  1590.  
  1591. static char s_strup[] = "string-upcase!";
  1592. SCM 
  1593. scm_strup (v)
  1594.      SCM v;
  1595. {
  1596.   register long k;
  1597.   register unsigned char *cs;
  1598.   ASRTGO (NIMP (v), badarg1);
  1599.   k = LENGTH (v);
  1600.   switch TYP7
  1601.     (v)
  1602.     {
  1603.     case tc7_string:
  1604.       cs = UCHARS (v);
  1605.       while (k--)
  1606.     cs[k] = scm_upcase[cs[k]];
  1607.       break;
  1608.     default:
  1609.     badarg1:scm_wta (v, (char *) ARG1, s_strup);
  1610.     }
  1611.   return v;
  1612. }
  1613.  
  1614. static char s_strdown[] = "string-downcase!";
  1615. SCM 
  1616. scm_strdown (v)
  1617.      SCM v;
  1618. {
  1619.   register long k;
  1620.   register unsigned char *cs;
  1621.   ASRTGO (NIMP (v), badarg1);
  1622.   k = LENGTH (v);
  1623.   switch TYP7
  1624.     (v)
  1625.     {
  1626.     case tc7_string:
  1627.       cs = UCHARS (v);
  1628.       while (k--)
  1629.     cs[k] = scm_downcase[cs[k]];
  1630.       break;
  1631.     default:
  1632.     badarg1:scm_wta (v, (char *) ARG1, s_strdown);
  1633.     }
  1634.   return v;
  1635. }
  1636.  
  1637. SCM 
  1638. scm_istr2bve (str, len)
  1639.      char *str;
  1640.      long len;
  1641. {
  1642.   SCM v = scm_make_uve (len, BOOL_T);
  1643.   long *data = (long *) VELTS (v);
  1644.   register unsigned long mask;
  1645.   register long k;
  1646.   register long j;
  1647.   for (k = 0; k < (len + LONG_BIT - 1) / LONG_BIT; k++)
  1648.     {
  1649.       data[k] = 0L;
  1650.       j = len - k * LONG_BIT;
  1651.       if (j > LONG_BIT)
  1652.     j = LONG_BIT;
  1653.       for (mask = 1L; j--; mask <<= 1)
  1654.     switch (*str++)
  1655.       {
  1656.       case '0':
  1657.         break;
  1658.       case '1':
  1659.         data[k] |= mask;
  1660.         break;
  1661.       default:
  1662.         return BOOL_F;
  1663.       }
  1664.     }
  1665.   return v;
  1666. }
  1667.  
  1668. static SCM 
  1669. ra2l (ra, base, k)
  1670.      SCM ra;
  1671.      sizet base;
  1672.      sizet k;
  1673. {
  1674.   register SCM res = EOL;
  1675.   register long inc = ARRAY_DIMS (ra)[k].inc;
  1676.   register sizet i;
  1677.   if (ARRAY_DIMS (ra)[k].ubnd < ARRAY_DIMS (ra)[k].lbnd)
  1678.     return EOL;
  1679.   i = base + (1 + ARRAY_DIMS (ra)[k].ubnd - ARRAY_DIMS (ra)[k].lbnd) * inc;
  1680.   if (k < ARRAY_NDIM (ra) - 1)
  1681.     {
  1682.       do
  1683.     {
  1684.       i -= inc;
  1685.       res = scm_cons (ra2l (ra, i, k + 1), res);
  1686.     }
  1687.       while (i != base);
  1688.     }
  1689.   else
  1690.     do
  1691.       {
  1692.     i -= inc;
  1693.     res = scm_cons (scm_aref (ARRAY_V (ra), MAKINUM (i)), res);
  1694.       }
  1695.     while (i != base);
  1696.   return res;
  1697. }
  1698.  
  1699. static char s_array2list[] = "array->list";
  1700. SCM 
  1701. scm_array2list (v)
  1702.      SCM v;
  1703. {
  1704.   SCM res = EOL;
  1705.   register long k;
  1706.   ASRTGO (NIMP (v), badarg1);
  1707.   switch TYP7
  1708.     (v)
  1709.     {
  1710.     default:
  1711.     badarg1:scm_wta (v, (char *) ARG1, s_array2list);
  1712.     case tc7_smob:
  1713.       ASRTGO (ARRAYP (v), badarg1);
  1714.       return ra2l (v, ARRAY_BASE (v), 0);
  1715.     case tc7_vector:
  1716.       return scm_vector2list (v);
  1717.     case tc7_string:
  1718.       return scm_string2list (v);
  1719.     case tc7_bvect:
  1720.       {
  1721.     long *data = (long *) VELTS (v);
  1722.     register unsigned long mask;
  1723.     for (k = (LENGTH (v) - 1) / LONG_BIT; k > 0; k--)
  1724.       for (mask = 1L << (LONG_BIT - 1); mask; mask >>= 1)
  1725.         res = scm_cons (((long *) data)[k] & mask ? BOOL_T : BOOL_F, res);
  1726.     for (mask = 1L << ((LENGTH (v) % LONG_BIT) - 1); mask; mask >>= 1)
  1727.       res = scm_cons (((long *) data)[k] & mask ? BOOL_T : BOOL_F, res);
  1728.     return res;
  1729.       }
  1730. # ifdef INUMS_ONLY
  1731.     case tc7_uvect:
  1732.     case tc7_ivect:
  1733.       {
  1734.     long *data = (long *) VELTS (v);
  1735.     for (k = LENGTH (v) - 1; k >= 0; k--)
  1736.       res = scm_cons (MAKINUM (data[k]), res);
  1737.     return res;
  1738.       }
  1739. # else
  1740.   case tc7_uvect: {
  1741.     long *data = (long *)VELTS(v);
  1742.     for (k = LENGTH(v) - 1; k >= 0; k--)
  1743.       res = scm_cons(scm_ulong2num(data[k]), res);
  1744.     return res;
  1745.   }
  1746.   case tc7_ivect: {
  1747.     long *data = (long *)VELTS(v);
  1748.     for (k = LENGTH(v) - 1; k >= 0; k--)
  1749.       res = scm_cons(long2num(data[k]), res);
  1750.     return res;
  1751.   }
  1752. # endif
  1753. #ifdef FLOATS
  1754. #ifdef SINGLES
  1755.     case tc7_fvect:
  1756.       {
  1757.     float *data = (float *) VELTS (v);
  1758.     for (k = LENGTH (v) - 1; k >= 0; k--)
  1759.       res = scm_cons (makflo (data[k]), res);
  1760.     return res;
  1761.       }
  1762. #endif /*SINGLES*/
  1763.     case tc7_dvect:
  1764.       {
  1765.     double *data = (double *) VELTS (v);
  1766.     for (k = LENGTH (v) - 1; k >= 0; k--)
  1767.       res = scm_cons (scm_makdbl (data[k], 0.0), res);
  1768.     return res;
  1769.       }
  1770.     case tc7_cvect:
  1771.       {
  1772.     double (*data)[2] = (double (*)[2]) VELTS (v);
  1773.     for (k = LENGTH (v) - 1; k >= 0; k--)
  1774.       res = scm_cons (scm_makdbl (data[k][0], data[k][1]), res);
  1775.     return res;
  1776.       }
  1777. #endif /*FLOATS*/
  1778.     }
  1779. }
  1780.  
  1781. static int l2ra P ((SCM lst, SCM ra, sizet base, sizet k));
  1782. static char s_bad_ralst[] = "Bad scm_array contents scm_list";
  1783. static char s_list2ura[] = "list->uniform-array";
  1784. SCM 
  1785. scm_list2ura (ndim, prot, lst)
  1786.      SCM ndim;
  1787.      SCM prot;
  1788.      SCM lst;
  1789. {
  1790.   SCM shp = EOL;
  1791.   SCM row = lst;
  1792.   SCM ra;
  1793.   sizet k;
  1794.   long n;
  1795.   ASSERT (INUMP (ndim), ndim, ARG1, s_list2ura);
  1796.   k = INUM (ndim);
  1797.   for (; k--; NIMP (row) && (row = CAR (row)))
  1798.     {
  1799.       n = scm_ilength (row);
  1800.       ASSERT (n >= 0, lst, ARG2, s_list2ura);
  1801.       shp = scm_cons (MAKINUM (n), shp);
  1802.     }
  1803.   ra = scm_dims2ura (scm_reverse (shp), prot, EOL);
  1804.   if (NULLP (shp))
  1805.  
  1806.     {
  1807.       ASRTGO (1 == scm_ilength (lst), badlst);
  1808.       scm_aset (ra, CAR (lst), EOL);
  1809.       return ra;
  1810.     }
  1811.   if (!ARRAYP (ra))
  1812.     {
  1813.       for (k = 0; k < LENGTH (ra); k++, lst = CDR (lst))
  1814.     scm_aset (ra, CAR (lst), MAKINUM (k));
  1815.       return ra;
  1816.     }
  1817.   if (l2ra (lst, ra, ARRAY_BASE (ra), 0))
  1818.     return ra;
  1819.   else
  1820.   badlst:scm_wta (lst, s_bad_ralst, s_list2ura);
  1821.   return BOOL_F;
  1822. }
  1823.  
  1824. static int 
  1825. l2ra (lst, ra, base, k)
  1826.      SCM lst;
  1827.      SCM ra;
  1828.      sizet base;
  1829.      sizet k;
  1830. {
  1831.   register long inc = ARRAY_DIMS (ra)[k].inc;
  1832.   register long n = (1 + ARRAY_DIMS (ra)[k].ubnd - ARRAY_DIMS (ra)[k].lbnd);
  1833.   int ok = 1;
  1834.   if (n <= 0)
  1835.     return (EOL == lst);
  1836.   if (k < ARRAY_NDIM (ra) - 1)
  1837.     {
  1838.       while (n--)
  1839.     {
  1840.       if (IMP (lst) || NCONSP (lst))
  1841.         return 0;
  1842.       ok = ok && l2ra (CAR (lst), ra, base, k + 1);
  1843.       base += inc;
  1844.       lst = CDR (lst);
  1845.     }
  1846.       if (NNULLP (lst))
  1847.  return 0;
  1848.     }
  1849.   else
  1850.     {
  1851.       while (n--)
  1852.     {
  1853.       if (IMP (lst) || NCONSP (lst))
  1854.         return 0;
  1855.       ok = ok && scm_aset (ARRAY_V (ra), CAR (lst), MAKINUM (base));
  1856.       base += inc;
  1857.       lst = CDR (lst);
  1858.     }
  1859.       if (NNULLP (lst))
  1860.  return 0;
  1861.     }
  1862.   return ok;
  1863. }
  1864.  
  1865. static void 
  1866. rapr1 (ra, j, k, port, writing)
  1867.      SCM ra;
  1868.      sizet j;
  1869.      sizet k;
  1870.      SCM port;
  1871.      int writing;
  1872. {
  1873.   long inc = 1;
  1874.   long n = LENGTH (ra);
  1875.   int enclosed = 0;
  1876. tail:
  1877.   switch TYP7
  1878.     (ra)
  1879.     {
  1880.     case tc7_smob:
  1881.       if (enclosed++)
  1882.     {
  1883.       ARRAY_BASE (ra) = j;
  1884.       if (n-- > 0)
  1885.         scm_iprin1 (ra, port, writing);
  1886.       for (j += inc; n-- > 0; j += inc)
  1887.         {
  1888.           scm_putc (' ', port);
  1889.           ARRAY_BASE (ra) = j;
  1890.           scm_iprin1 (ra, port, writing);
  1891.         }
  1892.       break;
  1893.     }
  1894.       if (k + 1 < ARRAY_NDIM (ra))
  1895.     {
  1896.       long i;
  1897.       inc = ARRAY_DIMS (ra)[k].inc;
  1898.       for (i = ARRAY_DIMS (ra)[k].lbnd; i < ARRAY_DIMS (ra)[k].ubnd; i++)
  1899.         {
  1900.           scm_putc ('(', port);
  1901.           rapr1 (ra, j, k + 1, port, writing);
  1902.           scm_lputs (") ", port);
  1903.           j += inc;
  1904.         }
  1905.       if (i == ARRAY_DIMS (ra)[k].ubnd)
  1906.         {            /* could be zero size. */
  1907.           scm_putc ('(', port);
  1908.           rapr1 (ra, j, k + 1, port, writing);
  1909.           scm_putc (')', port);
  1910.         }
  1911.       break;
  1912.     }
  1913.       if ARRAY_NDIM
  1914.     (ra)
  1915.     {            /* Could be zero-dimensional */
  1916.       inc = ARRAY_DIMS (ra)[k].inc;
  1917.       n = (ARRAY_DIMS (ra)[k].ubnd - ARRAY_DIMS (ra)[k].lbnd + 1);
  1918.     }
  1919.       else
  1920.     n = 1;
  1921.       ra = ARRAY_V (ra);
  1922.       goto tail;
  1923.     default:
  1924.       if (n-- > 0)
  1925.     scm_iprin1 (scm_aref (ra, MAKINUM (j)), port, writing);
  1926.       for (j += inc; n-- > 0; j += inc)
  1927.     {
  1928.       scm_putc (' ', port);
  1929.       scm_iprin1 (scm_cvref (ra, j, SCM_UNDEFINED), port, writing);
  1930.     }
  1931.       break;
  1932.     case tc7_string:
  1933.       if (n-- > 0)
  1934.     scm_iprin1 (MAKICHR (CHARS (ra)[j]), port, writing);
  1935.       if (writing)
  1936.     for (j += inc; n-- > 0; j += inc)
  1937.       {
  1938.         scm_putc (' ', port);
  1939.         scm_iprin1 (MAKICHR (CHARS (ra)[j]), port, writing);
  1940.       }
  1941.       else
  1942.     for (j += inc; n-- > 0; j += inc)
  1943.       scm_putc (CHARS (ra)[j], port);
  1944.       break;
  1945.     case tc7_uvect:
  1946.     case tc7_ivect:
  1947.       if (n-- > 0)
  1948.     scm_intprint (VELTS (ra)[j], 10, port);
  1949.       for (j += inc; n-- > 0; j += inc)
  1950.     {
  1951.       scm_putc (' ', port);
  1952.       scm_intprint (VELTS (ra)[j], 10, port);
  1953.     }
  1954.       break;
  1955. #ifdef FLOATS
  1956. #ifdef SINGLES
  1957.     case tc7_fvect:
  1958.       if (n-- > 0)
  1959.     {
  1960.       SCM z = makflo (1.0);
  1961.       FLO (z) = ((float *) VELTS (ra))[j];
  1962.       scm_floprint (z, port, writing);
  1963.       for (j += inc; n-- > 0; j += inc)
  1964.         {
  1965.           scm_putc (' ', port);
  1966.           FLO (z) = ((float *) VELTS (ra))[j];
  1967.           scm_floprint (z, port, writing);
  1968.         }
  1969.     }
  1970.       break;
  1971. #endif /*SINGLES*/
  1972.     case tc7_dvect:
  1973.       if (n-- > 0)
  1974.     {
  1975.       SCM z = scm_makdbl (1.0 / 3.0, 0.0);
  1976.       REAL (z) = ((double *) VELTS (ra))[j];
  1977.       scm_floprint (z, port, writing);
  1978.       for (j += inc; n-- > 0; j += inc)
  1979.         {
  1980.           scm_putc (' ', port);
  1981.           REAL (z) = ((double *) VELTS (ra))[j];
  1982.           scm_floprint (z, port, writing);
  1983.         }
  1984.     }
  1985.       break;
  1986.     case tc7_cvect:
  1987.       if (n-- > 0)
  1988.     {
  1989.       SCM cz = scm_makdbl (0.0, 1.0), z = scm_makdbl (1.0 / 3.0, 0.0);
  1990.       REAL (z) = REAL (cz) = (((double *) VELTS (ra))[2 * j]);
  1991.       IMAG (cz) = ((double *) VELTS (ra))[2 * j + 1];
  1992.       scm_floprint ((0.0 == IMAG (cz) ? z : cz), port, writing);
  1993.       for (j += inc; n-- > 0; j += inc)
  1994.         {
  1995.           scm_putc (' ', port);
  1996.           REAL (z) = REAL (cz) = ((double *) VELTS (ra))[2 * j];
  1997.           IMAG (cz) = ((double *) VELTS (ra))[2 * j + 1];
  1998.           scm_floprint ((0.0 == IMAG (cz) ? z : cz), port, writing);
  1999.         }
  2000.     }
  2001.       break;
  2002. #endif /*FLOATS*/
  2003.     }
  2004. }
  2005. int 
  2006. scm_raprin1 (exp, port, writing)
  2007.      SCM exp;
  2008.      SCM port;
  2009.      int writing;
  2010. {
  2011.   SCM v = exp;
  2012.   sizet base = 0;
  2013.   scm_putc ('#', port);
  2014. tail:
  2015.   switch TYP7
  2016.     (v)
  2017.     {
  2018.     case tc7_smob:
  2019.       {
  2020.     long ndim = ARRAY_NDIM (v);
  2021.     base = ARRAY_BASE (v);
  2022.     v = ARRAY_V (v);
  2023.     if (ARRAYP (v))
  2024.  
  2025.       {
  2026.         scm_lputs ("<enclosed-array ", port);
  2027.         rapr1 (exp, base, 0, port, writing);
  2028.         scm_putc ('>', port);
  2029.         return 1;
  2030.       }
  2031.     else
  2032.       {
  2033.         scm_intprint (ndim, 10, port);
  2034.         goto tail;
  2035.       }
  2036.       }
  2037.     case tc7_bvect:
  2038.       if (exp == v)
  2039.     {            /* a uve, not an scm_array */
  2040.       register long i, j, w;
  2041.       scm_putc ('*', port);
  2042.       for (i = 0; i < (LENGTH (exp)) / LONG_BIT; i++)
  2043.         {
  2044.           w = VELTS (exp)[i];
  2045.           for (j = LONG_BIT; j; j--)
  2046.         {
  2047.           scm_putc (w & 1 ? '1' : '0', port);
  2048.           w >>= 1;
  2049.         }
  2050.         }
  2051.       j = LENGTH (exp) % LONG_BIT;
  2052.       if (j)
  2053.         {
  2054.           w = VELTS (exp)[LENGTH (exp) / LONG_BIT];
  2055.           for (; j; j--)
  2056.         {
  2057.           scm_putc (w & 1 ? '1' : '0', port);
  2058.           w >>= 1;
  2059.         }
  2060.         }
  2061.       return 1;
  2062.     }
  2063.       else
  2064.     scm_putc ('b', port);
  2065.       break;
  2066.     case tc7_string:
  2067.       scm_putc ('a', port);
  2068.       break;
  2069.     case tc7_uvect:
  2070.       scm_putc ('u', port);
  2071.       break;
  2072.     case tc7_ivect:
  2073.       scm_putc ('e', port);
  2074.       break;
  2075. #ifdef FLOATS
  2076. #ifdef SINGLES
  2077.     case tc7_fvect:
  2078.       scm_putc ('s', port);
  2079.       break;
  2080. #endif /*SINGLES*/
  2081.     case tc7_dvect:
  2082.       scm_putc ('i', port);
  2083.       break;
  2084.     case tc7_cvect:
  2085.       scm_putc ('c', port);
  2086.       break;
  2087. #endif /*FLOATS*/
  2088.     }
  2089.   scm_putc ('(', port);
  2090.   rapr1 (exp, base, 0, port, writing);
  2091.   scm_putc (')', port);
  2092.   return 1;
  2093. }
  2094.  
  2095. static char s_array_prot[] = "array-prototype";
  2096. SCM 
  2097. scm_array_prot (ra)
  2098.      SCM ra;
  2099. {
  2100.   int enclosed = 0;
  2101.   ASRTGO (NIMP (ra), badarg);
  2102. loop:
  2103.   switch TYP7
  2104.     (ra)
  2105.     {
  2106.     default:
  2107.     badarg:scm_wta (ra, (char *) ARG1, s_array_prot);
  2108.     case tc7_smob:
  2109.       ASRTGO (ARRAYP (ra), badarg);
  2110.       if (enclosed++)
  2111.     return UNSPECIFIED;
  2112.       ra = ARRAY_V (ra);
  2113.       goto loop;
  2114.     case tc7_vector:
  2115.       return EOL;
  2116.     case tc7_bvect:
  2117.       return BOOL_T;
  2118.     case tc7_string:
  2119.       return MAKICHR ('a');
  2120.     case tc7_uvect:
  2121.       return MAKINUM (1L);
  2122.     case tc7_ivect:
  2123.       return MAKINUM (-1L);
  2124. #ifdef FLOATS
  2125. #ifdef SINGLES
  2126.     case tc7_fvect:
  2127.       return makflo (1.0);
  2128. #endif
  2129.     case tc7_dvect:
  2130.       return scm_makdbl (1.0 / 3.0, 0.0);
  2131.     case tc7_cvect:
  2132.       return scm_makdbl (0.0, 1.0);
  2133. #endif
  2134.     }
  2135. }
  2136.  
  2137. static scm_iproc subr3s[] =
  2138. {
  2139.   {"uniform-vector-set1!", scm_aset},
  2140.   {s_uve_pos, scm_position},
  2141.   {s_bit_set, scm_bit_set},
  2142.   {s_bit_count, scm_bit_count},
  2143.   {s_list2ura, scm_list2ura},
  2144.   {0, 0}};
  2145.  
  2146. static scm_iproc subr2s[] =
  2147. {
  2148.   {"uniform-vector-ref", scm_aref},
  2149.   {scm_s_resizuve, scm_resizuve},
  2150.   {s_count, scm_lcount},
  2151.   {0, 0}};
  2152.  
  2153. static scm_iproc subr1s[] =
  2154. {
  2155.   {"array-rank", scm_array_rank},
  2156.   {s_array_dims, scm_array_dims},
  2157.   {s_array2list, scm_array2list},
  2158.   {s_uve_len, scm_uve_len},
  2159.   {s_bit_inv, scm_bit_inv},
  2160.   {s_strdown, scm_strdown},
  2161.   {s_strup, scm_strup},
  2162.   {s_array_prot, scm_array_prot},
  2163.   {0, 0}};
  2164.  
  2165. static scm_iproc lsubrs[] =
  2166. {
  2167.   {s_aref, scm_array_ref},
  2168.   {s_trans_array, scm_trans_array},
  2169.   {s_encl_array, scm_encl_array},
  2170.   {s_array_inbp, scm_array_inbp},
  2171.   {0, 0}};
  2172.  
  2173. static scm_iproc lsubr2s[] =
  2174. {
  2175.   {scm_s_make_sh_array, scm_make_sh_array},
  2176.   {s_dims2ura, scm_dims2ura},
  2177.   {s_aset, scm_aset},
  2178.   {0, 0}};
  2179.  
  2180. static scm_iproc subr2os[] =
  2181. {
  2182.   {"array?", scm_arrayp},
  2183.   {s_array_contents, scm_array_contents},
  2184.   {s_ura_rd, scm_ura_read},
  2185.   {s_ura_wr, scm_ura_write},
  2186.   {0, 0}};
  2187.  
  2188. static SCM markra (ptr)
  2189.      SCM ptr;
  2190. {
  2191.   if GC8MARKP
  2192.     (ptr) return BOOL_F;
  2193.   SETGC8MARK (ptr);
  2194.   return ARRAY_V (ptr);
  2195. }
  2196. static sizet freera (ptr)
  2197.      CELLPTR ptr;
  2198. {
  2199.   scm_must_free (CHARS (ptr));
  2200.   return sizeof (scm_array) + ARRAY_NDIM (ptr) * sizeof (scm_array_dim);
  2201. }
  2202. static scm_smobfuns rasmob =
  2203. {markra, freera, scm_raprin1, scm_raequal};
  2204.  
  2205.  
  2206. /* This must be done after scm_init_scl() */
  2207. void scm_init_unif ()
  2208. {
  2209.   scm_init_iprocs (subr3s, tc7_subr_3);
  2210.   scm_init_iprocs (subr2s, tc7_subr_2);
  2211.   scm_init_iprocs (subr1s, tc7_subr_1);
  2212.   scm_init_iprocs (lsubrs, tc7_lsubr);
  2213.   scm_init_iprocs (lsubr2s, tc7_lsubr_2);
  2214.   scm_init_iprocs (subr2os, tc7_subr_2o);
  2215.   scm_tc16_array = scm_newsmob (&rasmob);
  2216.   scm_add_feature (s_array);
  2217. }
  2218.  
  2219. #else /* ARRAYS */
  2220.  
  2221. int 
  2222. scm_raprin1 (exp, port, writing)
  2223.      SCM exp;
  2224.      SCM port;
  2225.      int writing;
  2226. {
  2227.   return 0;
  2228. }
  2229.  
  2230. SCM 
  2231. scm_istr2bve (str, len)
  2232.      char *str;
  2233.      long len;
  2234. {
  2235.   return BOOL_F;
  2236. }
  2237.  
  2238. SCM 
  2239. scm_array_equal (ra0, ra1)
  2240.      SCM ra0, ra1;
  2241. {
  2242.   return BOOL_F;
  2243. }
  2244.  
  2245.  
  2246.  
  2247.  
  2248. void 
  2249. scm_init_unif ()
  2250. {
  2251.   scm_make_subr (scm_s_resizuve, tc7_subr_2, scm_resizuve);
  2252. }
  2253.  
  2254.  
  2255.  
  2256.  
  2257. #endif /* ARRAYS */
  2258.